Magnum One/Magnum One (Mid-American Digital) (Disc Manufacturing).iso/d12/v9n21.arc/DGSTR.PAS

Pascal/Delphi Source File | 1990-11-17 | 29KB | 912 lines

{
 ▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄
 █                                                                         █
 █        TITLE :      DGSTR.TPU                                           █
 █      PURPOSE :      Basic string-handling routines.                     █
 █       AUTHOR :      David Gerrold, CompuServe ID:  70307,544            █
 █  _____________________________________________________________________  █
 █                                                                         █
 █   Written in Turbo Pascal, Version 5.5,                                 █
 █   with routines from TurboPower, Object Professional.                   █
 █                                                                         █
 █   Turbo Pascal is a product of Borland International.                   █
 █   Object Professional is a product of TurboPower Software.              █
 █  _____________________________________________________________________  █
 █                                                                         █
 █   This is not public domain software.                                   █
 █   This software is copyright 1990, by David Gerrold.                    █
 █   Permission is hereby granted for personal use.                        █
 █                                                                         █
 █        The Brass Cannon Corporation                                     █
 █        9420 Reseda Blvd., #804                                          █
 █        Northridge, CA  91324-2932.                                      █
 █                                                                         █
 ▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀
                                                                            }
{ Compiler Directives ===================================================== }

{$A-}    {Switch word alignment off, necessary for cloning}
{$R-}    {Range checking off}
{$B-}    {Boolean complete evaluation off}
{$S-}    {Stack checking off}
{$I-}    {I/O checking off}
{$N+,E+} {Simulate numeric coprocessor}
{$M 16384,0,327680} {stack and heap}
{$V-}    {Variable range checking off}

{ Name ==================================================================== }

UNIT DgStr;
{
  The purpose of this code is to provide basic string-handling routines.
}

{ Interface =============================================================== }

INTERFACE

USES
{ Object Professional Units }
  OpString,

{ Dg Units }
  DgCh;

{ Declarations ============================================================ }

TYPE
  StringPtr  = ^string;
  String2    = string [2];
  String3    = string [3];
  String6    = string [6];
  String8    = string [8];
  String12   = string [12];
  String15   = string [15];
  String25   = string [25];
  String80   = string [80];

{ Functions and Procedure Declarations ==================================== }
{ Position functions ------------------------------------------------------ }

FUNCTION LastPos (SubStr, S : string) : byte;
{ Pos function that works from right to left, returns last pos of substr. }

{ Strip and Pad functions ------------------------------------------------- }

FUNCTION Strip (S : string;  Ch : char) : string;
{ Strips every occurrence of Ch from S. }

FUNCTION TrimLeadCh (S : string;  Ch : char) : string;
{ Trims all occurrences of Ch from the beginning of string S. }

FUNCTION TrimTrailCh (S : string;  Ch : char) : string;
{ Trims all occurrences of Ch from the end of string S. }

FUNCTION TrimCh (S : string;  Ch : char) : string;
{ Trims all occurrences of Ch from the beginning and end of string S. }

FUNCTION TrimThe (S : string) : string;
{ Removes 'A', 'An', and 'The' from the beginning of string S. }

FUNCTION PadCenter (S : string;  Width : byte) : string;
{ Pads S with spaces on both sides to produce a centered string. }

FUNCTION SpaceFix (S : string) : string;
{ Loops through S, corrects spacing between words. }

{ Capitalization functions ------------------------------------------------ }

FUNCTION CapFirst (S : string) : string;
{ Capitalizes the first letter in the string. }

FUNCTION CapWords (S : string) : string;
{ Capitalizes first letter of every word in the string. }

{ Translation functions --------------------------------------------------- }

PROCEDURE OverWrite (VAR S : string;  SubStr : string;  Position : byte);
{ Replaces text in S at Position with text in SubStr. }

PROCEDURE Replace (VAR S : string;  OldStr, NewStr : string);
{ Finds OldStr in S and replaces it with NewStr. }

PROCEDURE ReplaceAll (VAR S : string;  OldStr, NewStr : string);
{ Replaces all occurrences of OldStr with NewStr. }

PROCEDURE Translate (VAR S : string;  OldCh, NewCh : char);
{ Translates every occurrence of OldCh into NewCh. }

FUNCTION TranslateRaw (S : string) : string;
{ Translates code into strings:  ^E becomes ctrl char,
  #39 becomes apostrophe, etc. }

{ Number functions -------------------------------------------------------- }

FUNCTION Num2Str (Num : float) : string;
{ Returns a number in shortest possible string. }

FUNCTION ContainsNumber (S : string) : boolean;
{ Returns true if S contains any digits. }

{ Extraction functions ---------------------------------------------------- }

FUNCTION GetSubStr (S : string; Pos1, Pos2 : byte) : string;
{ Extracts a SubString, starting at Pos1, ending at Pos2. }

FUNCTION ExtractFirstWord (VAR S : string) : string;
{ Returns first word in string, deletes it from source. }

FUNCTION ExtractFirstNumber (VAR S : string) : word;
{ Returns first number in string, or zero on failure. }

FUNCTION ExtractFirstExtended (S : string) : extended;
{ Returns first number in string, or zero on failure. }

{ String Formatting functions --------------------------------------------- }

FUNCTION Justify (S : string80;  W : byte) : string80;
{ returns a string padded internally to length W }

{ Hashing functions ------------------------------------------------------- }

FUNCTION MultiSoundex (S : string) : string;
{ Returns multiple soundex string for multiple words. }

FUNCTION Compress (S : string) : string;
{ Compresses text string at a ratio of 8:5. }

FUNCTION Decompress (S : string) : string;
{ Decompresses text string at a ratio of 5:8. }

FUNCTION HashVal (S : String) : extended;
{ Returns a hash value based on the first 10 characters of the string. }

{ ========================================================================= }
{ Implementation ========================================================== }

IMPLEMENTATION

{ ========================================================================= }
{ LastPos ================================================================= }

FUNCTION LastPos (SubStr, S : string) : byte;
{ Pos function that works from right to left, returns last pos of substr. }

VAR
  Loop : byte;
  Len  : byte absolute S;
  SLen : byte absolute SubStr;

BEGIN
  Loop := succ (Len - SLen);
  While
    (Loop > 0)
      and
    (Copy (S, Loop, SLen) <> SubStr)
  do
    dec (Loop);
  LastPos := Loop;
END;

{ ========================================================================= }
{ Strip =================================================================== }

FUNCTION Strip (S : string;  Ch : char) : string;
{ Strips every occurrence of Ch from S. }

VAR
  Len  : byte absolute S;
  Loop : byte;

BEGIN
  S := TrimCh (S, Ch);
  For Loop := Len downto 1 do                    { step backward }
    If S [Loop] = Ch then begin
      move (S [succ (Loop)], S [Loop], Len - Loop);
      dec (Len);
      end;
  Strip := S;
END;

{ TrimLeadCh ============================================================== }

FUNCTION TrimLeadCh (S : string;  Ch : char) : string;
{ Trims all occurrences of Ch from the beginning of string S. }

VAR
  Len  : byte absolute S;

BEGIN
  While
    (S [1] = Ch) and (Len > 0)                   { while S [1] = Ch }
  do begin
    dec (Len);                                   { shorten S }
    move (S [2], S [1], Len);                    { delete 1st char }
    end;
  TrimLeadCh := S;                               { return }
END;

{ TrimTrailCh ============================================================= }

FUNCTION TrimTrailCh (S : string;  Ch : char) : string;
{ Trims all occurrences of Ch from the end of string S. }

VAR
  Len  : byte absolute S;

BEGIN
  While
    (S [Len] = Ch)                               { while last char = Ch }
  do
    dec (Len);                                   { shorten S }
  TrimTrailCh := S;                              { return }
END;

{ TrimCh ================================================================== }

FUNCTION TrimCh (S : string;  Ch : char) : string;
{ Trims all occurrences of Ch from the beginning and end of string S. }

BEGIN
  TrimCh := TrimTrailCh (TrimLeadCh (S, Ch), Ch);
END;

{ TrimThe ================================================================= }

FUNCTION TrimThe (S : string) : string;
{ Removes 'A', 'An', and 'The' from the beginning of string S. }

BEGIN
  if CompUCString ('A ', Copy (S, 1, 2)) = Equal then
    delete (S, 1, 2)
  else
    if CompUCString ('AN ', Copy (S, 1, 3)) = Equal then
      delete (S, 1, 3)
    else
      if CompUCString ('THE ', Copy (S, 1, 4)) = Equal then
        delete (S, 1, 4);
  TrimThe := S;
END;

{ PadCenter =============================================================== }

FUNCTION PadCenter (S : string;  Width : byte) : string;
{ Pads S with spaces on both sides to produce a centered string. }

VAR
  Len  : byte absolute S;

BEGIN
  PadCenter := Pad (LeftPad (S, Len + (Width - Len) div 2), Width);
END;

{ SpaceFix ================================================================ }

FUNCTION SpaceFix (S : string) : string;
{ Loops through S, corrects spacing between words. }
VAR
  Loop : byte;
  Len  : byte absolute S;
  SpaceFlag : boolean;

BEGIN
  Loop := Len;
  SpaceFlag := In2SpacePunctuation (S [Len]);
  repeat
    dec (Loop);
    if S [Loop] = ' ' then begin
      if SpaceFlag then delete (S, Loop, 1);
      SpaceFlag := true;
      end
    else begin
      if SpaceFlag and In2SpacePunctuation (S [Loop]) then
        insert (' ', S, succ (Loop));
      SpaceFlag := false;
      end;
  until
    Loop = 1;

  ReplaceAll (S, 'Dr.  ',  'Dr. ');              { save honorifics }
  ReplaceAll (S, 'Mr.  ',  'Mr. ');
  ReplaceAll (S, 'Mrs.  ', 'Mrs. ');
  ReplaceAll (S, 'Ms.  ',  'Ms. ');
  ReplaceAll (S, 'St.  ',  'St. ');

  SpaceFix := S;
END;

{ ========================================================================= }
{ CapFirst ---------------------------------------------------------------- }

FUNCTION CapFirst (S : string) : string;
{ Capitalizes the first letter in the string. }

BEGIN
  S := StLoCase (S);                             { lower case string }
  S [1] := UpCaseMac (S [1]);                    { upper case first letter }
  CapFirst := S;                                 { return }
END;

{ CapWords ================================================================ }

FUNCTION CapWords (S : string) : string;
{ Capitalizes first letter of every word in the string. }

VAR
  Loop : byte;
  Len  : byte absolute S;

BEGIN
  S := StLoCase (S);                             { lower case string }
  S [1] := UpCaseMac (S [1]);                    { Cap first letter }
  For Loop := 2 to Len do
    If (S [Loop] <> ' ') and (S [pred (Loop)] = ' ') then
      S [Loop] := UpCaseMac (S [Loop]);
  CapWords := S;
END;

{ ========================================================================= }
{ OverWrite =============================================================== }

PROCEDURE OverWrite (VAR S : string;  SubStr : string;  Position : byte);
{
  Replaces text in S at Position with text in SubStr.

  Although it would be faster to use 'move (OverStr, S, OverStrLen)',
  that method does not correctly manage the length of S.  In specific,
  using move does not allow S to concatenate extra chars if OverStr
  goes beyond its length, nor will move manage the automatic truncation
  of S if it grows beyond 255 chars.
}

VAR
  SLen : byte absolute SubStr;

BEGIN
  delete (S, Position, SLen);                    { delete current text }
  insert (SubStr, S, Position);                  { insert new text }
END;

{ Replace ================================================================= }

PROCEDURE Replace (VAR S : string;  OldStr, NewStr : string);
{ Finds OldStr in S and replaces it with NewStr. }

VAR
  Position  : byte;
  OldStrLen : byte absolute OldStr;

BEGIN
  Position := Pos (StUpCase (OldStr), StUpCase (S));  { find OldStr }
  If Position > 0 then begin                          { if OldStr exists }
    delete (S, Position, OldStrLen);                  { delete it }
    insert (NewStr, S, Position);                     { insert NewStr }
    end;
END;

{ ReplaceAll ============================================================== }

PROCEDURE ReplaceAll (VAR S : string;  OldStr, NewStr : string);
{ Replaces all occurrences of OldStr with NewStr. }

VAR
  Position  : byte;
  OldStrLen : byte absolute OldStr;

BEGIN
  Repeat
    Position := Pos (StUpCase (OldStr), StUpCase (S));  { find OldStr }
    If Position > 0 then begin                          { if OldStr exists }
      delete (S, Position, OldStrLen);                  { delete it }
      insert (NewStr, S, Position);                     { insert NewStr }
      end;
  until
    Position = 0;
END;

{ Translate =============================================================== }

PROCEDURE Translate (VAR S : string;  OldCh, NewCh : char);
{ Translates every occurrence of OldCh into NewCh. }

VAR
  Len  : byte absolute S;
  Loop : byte;

BEGIN
  If OldCh <> NewCh then
    For Loop := 1 to Len do
      If S [Loop] = OldCh then
        S [Loop] := NewCh;
END;

{ TranslateRaw ============================================================ }

FUNCTION TranslateRaw (S : string) : string;
{
  Translates code into strings.

  ^E becomes actual ctrl character.
  #39 becomes char (39).
  Text between apostrophes remains unchanged.

  Useful for translating variable strings from text files.  No
  error-trapping here.  Routine tends to ignore what it doesn't
  understand.  Use with caution.  Make sure input strings are
  valid or results may be unpredictable.
}

VAR
  Temp   : string;
  Len    : byte absolute S;
  Loop   : byte;
  NumStr : string3;
  W      : word;
  Ch     : char;
  Flag   : boolean;                              { read chars between '' }

BEGIN
  Loop := 1;
  Temp := '';
  Flag := false;

  While
    Loop <= Len
  do begin
    if
      Flag and (S [Loop] <> #39)
    then
      Temp := Temp + S [Loop]
    else
      Case S [Loop] of
        '^' : begin                              { Control Character }
              inc (Loop);
              Ch := Chr (Ord (UpCaseMac (S [Loop])) - 64);
              If (Ch >= #0) and (Ch < #32) then Temp := Temp + Ch;
              end;
        '#' : begin                              { Decimal Character }
              inc (Loop);
              NumStr := '';
              While
                (S [Loop] >= '0')
                  and (S [Loop] <= '9')
                    and (Loop <= Len)
              do begin
                NumStr := NumStr + S [Loop];
                Inc (Loop);
                end;
              dec (Loop);
              If Str2Word (NumStr, W) then
                Temp := Temp + Chr (W);
              end;
        #39 : if
                Flag and (Loop < pred (Len)) and (S [succ (Loop)] = #39)
              then begin
                inc (Loop);
                Temp := Temp + S [Loop];
                end
              else
                Flag := not Flag;
        end; { Case }
    inc (Loop);
    end;
  TranslateRaw := Temp;
END;

{ ========================================================================= }
{ Num2Str ================================================================= }

FUNCTION Num2Str (Num : float) : string;
{ Returns a number in shortest possible string. }

VAR
  S        : string;
  Len      : byte absolute S;
  ExpStr   : string [4];
  EPos,
  E        : word;

BEGIN
  Num2Str := '0';
  if Num = 0 then exit;

  If (abs (Num) > 1E+10) or (abs (Num) < 1E-10) then begin
    S := Trim (Real2Str (Num, 25, -1));
    EPos   := Pos ('E', S);                      { where is 'E' ? }
    ExpStr := GetSubStr (S, EPos + 2, Len);
    S := TrimTrailCh (
           TrimTrailCh (
             GetSubStr (S, 1, pred (Epos)),
           '0'),
         '.') +
         GetSubStr (S, EPos, Succ (EPos)) +    { is E + or - ? }
         TrimLeadCh (GetSubStr (S, EPos + 2, Len), '0');
    end
  else
    S := TrimTrailCh (
           TrimTrailCh (
             Trim (
               Real2Str (Num, 35, 18)
             ),
           '0'),
         '.');

  Num2Str := S;
END;

{ ContainsNumber ========================================================== }

FUNCTION ContainsNumber (S : string) : boolean;
{ Returns true if S contains any digits. }

VAR
  Len  : byte absolute S;
  Flag : boolean;
  Loop : byte;

BEGIN
  Flag := false;
  If Len > 0 then begin
    Loop := 1;
    Repeat
      Flag := InNumbers (S [Loop]);
      inc (Loop);
    Until
      Flag or (Loop > Len);
    end;
  ContainsNumber := Flag;
END;

{ ========================================================================= }
{ GetSubStr =============================================================== }

FUNCTION GetSubStr (S : string; Pos1, Pos2 : byte) : string;
{ Extracts a SubString, starting at Pos1, ending at Pos2. }

BEGIN
  GetSubStr := Copy (S, Pos1, succ (Pos2) - Pos1);
END;

{ ExtractFirstWord ======================================================== }

FUNCTION ExtractFirstWord (VAR S : string) : string;
{ Returns first word in string, deletes it from source. }

VAR
  Loop : byte;
  Len  : byte absolute S;

BEGIN
  ExtractFirstWord := '';

  Loop := 0;
  repeat                                         { look for start of word }
    inc (Loop)
  until
    (Loop > Len)
      or
    InAlphabet (S [Loop]);
  delete (S, 1, pred (Loop));

  Loop := 0;
  repeat                                         { look for end of word }
    inc (Loop)
  until
    (Loop > Len)
      or
    not InAlphabet (S [Loop]);
  dec (Loop);

  if Loop > 0 then begin
    ExtractFirstWord := GetSubStr (S, 1, Loop);
    Delete (S, 1, Loop);
    end;
  S := Trim (S);
END;

{ ExtractFirstNumber ====================================================== }

FUNCTION ExtractFirstNumber (VAR S : string) : word;
{
  Returns first number in string, or zero on failure.
  Deletes first number, if found.
}

VAR
  Len  : byte absolute S;
  Loop : byte;
  N    : word;

BEGIN
  ExtractFirstNumber := 0;
  If not ContainsNumber (S) then exit;

  Loop := 0;
  repeat                                         { look for start of word }
    inc (Loop)
  until
    (Loop > Len)
      or
    InNumbers (S [Loop])
      or
    (S [Loop] = '-');
  delete (S, 1, pred (Loop));

  Loop := 0;
  repeat                                         { look for end of word }
    inc (Loop)
  until
    (Loop > Len)
      or
    not InNumbers (S [Loop]);
  dec (Loop);

  if Loop > 0 then
    if Str2Word (GetSubStr (S, 1, Loop), N) then begin
      ExtractFirstNumber := N;
      delete (S, 1, Loop);
      end;
END;

{ ExtractFirstExtended ==================================================== }

FUNCTION ExtractFirstExtended (S : string) : extended;
{ Returns first number in string, or zero on failure. }

VAR
  Len  : byte absolute S;
  Loop : byte;
  N    : float;

BEGIN
  ExtractFirstExtended := 0;
  If not ContainsNumber (S) then exit;

  Loop := 0;
  repeat                                         { look for start of word }
    inc (Loop)
  until
    (Loop > Len)
      or
    InDecNumbers (S [Loop])
      or
    (S [Loop] = '-');
  delete (S, 1, pred (Loop));

  Loop := 0;
  repeat                                         { look for end of word }
    inc (Loop)
  until
    (Loop > Len)
      or
    not InDecNumbers (S [Loop]);
  dec (Loop);

  if Loop > 0 then
    if Str2Real (GetSubStr (S, 1, Loop), N) then begin
      ExtractFirstExtended := N;
      delete (S, 1, Loop);
      end;
END;

{ ========================================================================= }
{ Justify ================================================================= }

FUNCTION Justify (S : string80;  W : byte) : string80;
{
  Returns a string padded internally to length W.  Function assumes
  that trailing spaces have been trimmed from string S.  Allows for
  a five-space paragraph indentation at the beginning of a line.

  Justify counts through a string, adding spaces as equally as it can,
  either from left to right or right to left depending on the status
  of the (boolean) FlipFlag.  The purpose of the FlipFlag is to prevent
  an uneven clumping of spaces on either the left or the right side of
  the column.

  The formula for adding spaces is just a simple division of how many
  spaces we have to add (over how many we've already added) compared to
  how many spaces to add them to (over how many spaces we've already
  passed).  It's a little tricky to explain, but it works very well.
}

VAR
  Len : byte absolute S;                         { length of S }
  Loop,
  StartPos,                                      { where to start }
  SpacesInS,                                     { how many spaces in S }
  SpaceCtr,                                      { for counting the spaces }
  InsertCtr,                                     { how many spaces added }
  AddHowMany : byte;                             { how many spaces to add }

CONST
  FlipFlag : boolean = true;

BEGIN
  While Len < W do begin
    StartPos :=                                  { start count at what pos }
      succ (5 * ord (Pos ('     ', S) = 1));     { allow for new paragraph }
    SpacesInS := 0;                              { zero out counter }
    For Loop := StartPos to Len do               { loop through string }
      if S [Loop] = ' ' then
        inc (SpacesInS);                         { count spaces in S }
    AddHowMany := W - Len;                       { add how many spaces? }
    InsertCtr := 0;                              { how many inserted? }
    SpaceCtr := 0;                               { how many checked? }
    if FlipFlag then begin                       { left to right? }
      Loop := StartPos;
      Repeat
        inc (Loop);                              { step through S }
        if S [Loop] = ' ' then begin             { if space ... }
          if                                     { compute the spread }
            (InsertCtr/AddHowMany <= SpaceCtr/SpacesInS)
          then begin
            Insert (' ', S, Loop);               { add space }
            inc (InsertCtr);                     { count it }
            inc (Loop);
            end;
          inc (SpaceCtr);                        { count spaces in S }
          end;
      Until                                      { until ... }
        SpaceCtr/SpacesInS = 1;                  { we run out of spaces }
      end
    else begin                                   { right to left }
      Loop := W;
      Repeat
        dec (Loop);                              { step backward through S }
        if S [Loop] = ' ' then begin
          if
            (InsertCtr/AddHowMany <= SpaceCtr/SpacesInS)
          then begin
            Insert (' ', S, succ (Loop));        { add space }
            inc (InsertCtr);                     { count it }
            end;
          Inc (SpaceCtr);                        { count spaces }
          end;
      Until                                      { until ... }
        Loop = StartPos;                         { we get to the beginning }
      end;
    FlipFlag := not FlipFlag;                    { next time, go other way }
    end;
  Justify:= S;                                  { return to calling proc }
END;

{ ========================================================================= }
{ MultiSoundex ============================================================ }

FUNCTION MultiSoundex (S : string) : string;
{ Returns multiple soundex string for multiple words. }

VAR
  Temp : StringPtr;

BEGIN
  New (Temp);                                    { get memory }
  Temp^ := '';
  Repeat
    Temp^ := Temp^ + Soundex (ExtractFirstWord (S));
  Until
    S = '';
  MultiSoundex := Temp^;
  Dispose (Temp);
END;

{ Compress ================================================================ }

FUNCTION Compress (S : string) : string;
{
  Takes S and compresses it at a ratio of 8:5.  Compression works by
  converting 8-bit ASCII chararcters into 5-bit code.  Only letters
  are unique.  Numbers and punctuation are ignored.  Based on routines
  from Scott Bussinger.  See PC-Techniques, Vol 1.1.
}

VAR
  Len         : byte absolute S;
  I           : word;
  J           : word;
  BitMask     : word;
  ShiftFactor : word;
  ResultStr   : string;

BEGIN
  FillChar (ResultStr, sizeof (ResultStr), 0);   { Initialize result }
  J := 1;
  for I := 1 to Len do begin                     { Pack each char in turn }
    ShiftFactor := (I + I + I) and 7;
    case S [I] of
      '0'..'9'  : BitMask := 27;
      'a'..'z',
      'A'..'Z'  : BitMask := ord (S [I]) and $1F;
    else
      BitMask := 0
      end;  { case }
    BitMask := BitMask shl ShiftFactor;
    ResultStr [J] := chr (ord (ResultStr [J]) or lo (BitMask));
    ResultStr [pred (J)] := chr (ord (ResultStr [pred (J)]) or hi (BitMask));
    if ShiftFactor < 5 then
      inc (J)
    end;
  ResultStr [0] := chr ((5 * Len + 7) shr 3);    { Set new length }
  Compress := ResultStr
END;

{ Decompress ============================================================== }

FUNCTION Decompress (S : string) : string;
{
  Takes compressed string S and decompresses it at a ratio of 5:8.
  All letters are capitalized.  Numbers and punctuation are blanked.
  Based on routines from Scott Bussinger.
}

TYPE
  WordPtr = ^word;

VAR
  Len         : byte absolute S;
  I           : word;
  J           : word;
  ResultStr   : string;
  ShiftFactor : word;

BEGIN
  ResultStr [0] := chr ((8 * Len + 4) div 5);
  FillChar (S [succ (Len)], 255 - Len, 0);
    { In case we have a partially used last byte }
  J := 0;
  for I := 1 to length (ResultStr) do begin      { Get each char in turn }
    ShiftFactor := (I + I + I) and 7;
    ResultStr [I] := chr ((swap (WordPtr (@S [J])^) shr ShiftFactor)
                          and $1F or $40);
    case ResultStr [I] of
      'A'..'Z': ;
    else
      ResultStr[I] := ' ';                       { Blank out odd chars }
      end;
    if ShiftFactor < 5 then
      inc (J);
    end;
  Decompress := Trim (ResultStr);
END;

{ HashVal ================================================================= }

FUNCTION HashVal (S : String) : extended;
{ Returns a hash value based on the first 10 characters of the string. }

VAR
  Count : extended;
  Loop  : byte;
  Len   : byte absolute S;

BEGIN
  S := Pad (S, 10);
  Count := 0;
  For Loop := Len downto 1 do
    if
      (S [Loop] >= 'A') and (S [Loop] <= 'z')
    then
      Count := ord (UpCaseMac (S [Loop])) - 33 + Count/17;
  HashVal := abs (Count * 0.033 - 1) ;
End;

{ ========================================================================= }
{ ========================================================================= }

{ no initialization needed }
END.

{ ========================================================================= }
{ ========================================================================= }

VERSION HISTORY:
  9005.05
    Completely restructured for consistency with Object Professional.

{ ========================================================================= }

NOTES:

{ ========================================================================= }